﻿\ From: John Hayes S1I
\ Subject: core.fr
\ Date: Mon, 27 Nov 95 13:10



\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
\ VERSION 1.2
\ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM.
\ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE
\ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND
\ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1.
\ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"...
\ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?...

\ Adepted and modified by G.W. van der Vegt for use with SharpForth.
\ 1) Completly rewritten the test runner.
\ 2) Added most Core tests.
\ 3) Disabled test that fail or cannot run due to Architectureal Differences.

DECIMAL

\ Number of cells alloted for actual and expected output.
10 CONSTANT SIZE

\ Define variables
0     VALUE INDEX  
0     VALUE SKIPPED  
0     VALUE ADEPTH 
FALSE VALUE ERROR  

\ Actual Depth
0     VALUE DA     

\ Expected Depth
0     VALUE DE     

\[ 42 EMIT ]

\ Allot some memory. CREATE FAILS
CREATE OUTPUT SIZE CELLS ALLOT
CREATE EXPECTED SIZE CELLS ALLOT

: EMPTY-STACK														\ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
   DEPTH ?DUP 
   IF DUP 0< 
     IF 
       NEGATE 0 
         DO 
           0 
         LOOP 
     ELSE 
       0 
       DO 
         DROP 
       LOOP
     THEN 
   THEN 
;

: EMPTY-STORAGE 
  \ Clear Actual and Expected Storage.
  \ SIZE 0 DO 0 OUTPUT I CELLS + ! LOOP
  \ SIZE 0 DO 0 EXPECTED I CELLS + ! LOOP
  OUTPUT SIZE CELLS ERASE
  EXPECTED SIZE CELLS ERASE

  \ SEE OUTPUT 
  \ SEE EXPECTED
;

EMPTY-STORAGE 
EMPTY-STACK

\ CLS


\ Start of a Test
: { 
  \ PRINT-STACK-TRACE
  \ Increment Counter.
  INDEX 1 + TO INDEX 
  
  EMPTY-STORAGE
;

\ Marker between Test and Expected Output.
: -> 
  DEPTH TO DA  
;

\ End of Test, Evaluate Output.
: } 
  DEPTH DA - TO DE
  
  CR ." Test Index=  " INDEX 4 .R SPACE
  
  \ Stack Size Test
  DA DE <> IF 
    TRUE TO ERROR 
    ." - ERROR: Stack size mismatch" 
    CR ." : Depth Actual=" DA . 
    CR ." : Depth Expect=" DE . 
  THEN

  \ Stack Compare
	DE 0 > IF
      DE 0 
      DO EXPECTED I 1 CELLS * + ! LOOP 
	THEN

	DA 0 > IF
      DA 0 
      DO OUTPUT I 1 CELLS * + ! LOOP
	THEN 

  \ Error
  DEPTH 0 <> IF 
     CR
     CR 
     TRUE TO ERROR 
     ." - ERROR: Stack should be empty after checking" 
  THEN

  \ Compare
  DE 0 DO 
    EXPECTED I CELLS + @ 
    OUTPUT I CELLS + @ <> IF 
      \ ERROR IF  
	  \  I .
	  \ ELSE
	  \  CR ." - ERROR: Stack compare failure at index " I .
      \ THEN

	  TRUE TO ERROR 
      CR ." - ERROR: Stack compare failure at index " I .
      \ LEAVE
    THEN
  LOOP
  
  \ Show OUPUT
  ERROR IF
    CR 
    SEE EXPECTED
    SEE OUTPUT
  THEN

  ERROR NOT IF
     ." - Passed"
  THEN

  EMPTY-STACK
  
  ERROR IF FLUSH THEN
;

: .{ ( \"ccc<paren>}" -- )
  \ Increment Counter.
  SKIPPED 1 + TO SKIPPED 
  CR 5 SPACES '{' EMIT SPACE BEGIN KEY DUP '}' = IF DROP '}' EMIT SPACE ." WARNING: Test Disabled " EXIT THEN EMIT AGAIN
  
; IMMEDIATE

load-file test-core.f
\ load-file test-single.f
\ load-file test-console.f
\ load-file test-search.f

load-file test-summary.f